home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / macros.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-09-13  |  30.5 KB  |  911 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Macros global variable definitions, and other random support stuff used
  28. ;;; by the rest of the system.
  29. ;;;
  30. ;;; For simplicity (not having to use eval-when a lot), this file must be
  31. ;;; loaded before it can be compiled.
  32. ;;;
  33.  
  34. (in-package 'pcl)
  35.  
  36. (proclaim '(declaration
  37.          #-Genera values          ;I use this so that Zwei can remind
  38.                       ;me what values a function returns.
  39.          
  40.          #-Genera arglist          ;Tells me what the pretty arglist
  41.                       ;of something (which probably takes
  42.                       ;&rest args) is.
  43.  
  44.          #-Genera indentation     ;Tells ZWEI how to indent things
  45.                           ;like defclass.
  46.          class
  47.          variable-rebinding
  48.          pcl-fast-call
  49.          specializer-names
  50.          ))
  51.  
  52. ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist
  53. ;;; in other packages in all CommonLisp implementations, but I will leave it
  54. ;;; to the compiler to optimize into calls to them.
  55. ;;;
  56. ;;; Common Lisp BUG:
  57. ;;;    Some Common Lisps define these in the Lisp package which causes
  58. ;;;    all sorts of lossage.  Common Lisp should explictly specify which
  59. ;;;    symbols appear in the Lisp package.
  60. ;;;
  61. (eval-when (compile load eval)
  62.  
  63. (defmacro memq (item list) `(member ,item ,list :test #'eq))
  64. (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
  65. (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
  66. (defmacro delq (item list) `(delete ,item ,list :test #'eq))
  67. (defmacro posq (item list) `(position ,item ,list :test #'eq))
  68. (defmacro neq (x y) `(not (eq ,x ,y)))
  69.  
  70.  
  71. (defun make-caxr (n form)
  72.   (declare (type fixnum n))
  73.   (if (< n 4)
  74.       `(,(nth n '(car cadr caddr cadddr)) ,form)
  75.       (make-caxr (the fixnum (- n 4)) `(cddddr ,form))))
  76.  
  77. (defun make-cdxr (n form)
  78.   (declare (type fixnum n))
  79.   (cond ((zerop n) form)
  80.     ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
  81.     (t (make-cdxr (the fixnum (- n 4)) `(cddddr ,form)))))
  82. )
  83.  
  84.  
  85. (defun true (&rest ignore) (declare (ignore ignore)) t)
  86. (defun false (&rest ignore) (declare (ignore ignore)) nil)
  87. (defun zero (&rest ignore) (declare (ignore ignore)) 0)
  88. (defvar *keyword-package* (find-package 'keyword))
  89.  
  90. (defun make-plist (keys vals)
  91.   (if (null vals)
  92.       ()
  93.       (list* (car keys)
  94.          (car vals)
  95.          (make-plist (cdr keys) (cdr vals)))))
  96.  
  97. (defun remtail (list tail)
  98.   (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
  99.  
  100. ;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just
  101. ;;; lifted it from there but I am honest.  Not only that but this one is
  102. ;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more
  103. ;;; like rebuilding Rome.
  104. ;;;
  105. ;;; Modified 5/8/92 to work right on THE forms and to not  wrap an
  106. ;;; extra lambda if none of the variables are complex -- TL.
  107.  
  108. (defun un-the (form)
  109.   "Returns the actual form within a form that may start with THE."
  110.   (if (and (listp form) (eq (car form) 'the))
  111.       (un-the (third form))
  112.       form))
  113.  
  114. (defun simple-eval-access-p (form)
  115.   "Returns whether evaluation of the form is 'simple', i.e. does not
  116.    require computation to calculate.  This is true of constants, variables,
  117.    and functions."
  118.   (or (constantp form)                ;; Form is a constant?
  119.       (symbolp   form)                ;; Form is a variable?
  120.       (and (listp form)
  121.            (eq (car form) 'function)) ;; Form is a function?
  122.       (and (listp form)               ;; If form starts with THE, the real form
  123.            (eq (car form) 'the)       ;;   third element.
  124.            (simple-eval-access-p (third form)))))
  125.  
  126. (defmacro once-only (vars &body body)
  127.   (let ((gensym-var (gensym))
  128.         (run-time-vars (gensym "RUN-TIME-VARS"))
  129.         (run-time-vals (gensym "RUN-TIME-VALS"))
  130.         (expand-time-val-forms ()))
  131.     (dolist (var vars)
  132.       (push `(if (simple-eval-access-p ,var)
  133.                  ,var
  134.                  (let ((,gensym-var (gensym ,(symbol-name var))))
  135.                    (push ,gensym-var ,run-time-vars)
  136.                    (push ,var ,run-time-vals)
  137.                    ,gensym-var))
  138.             expand-time-val-forms))
  139.     `(let* (,run-time-vars
  140.             ,run-time-vals
  141.             (wrapped-body
  142.           (let ,(mapcar #'list vars (reverse expand-time-val-forms))
  143.         ,@body)))
  144.        (if ,run-time-vars
  145.            `(let ,(mapcar #'list (reverse ,run-time-vars)
  146.                                  (reverse ,run-time-vals))
  147.              ,wrapped-body)
  148.          wrapped-body))))
  149.  
  150. (defun declaimed-p-name (name)
  151.   (if (consp name)
  152.       (get-internal-setf-function-name (cadr name))
  153.       name))
  154.  
  155. #-(or cmu)  ; And probably others, but this is the only I know.
  156. (unless (fboundp 'declaim)
  157.   (defmacro declaim (&rest decl-specs)
  158.     (let ((proclamations NIL))
  159.       (declare (list proclamations))
  160.       (dolist (decl-spec decl-specs)
  161.         #-(or cmu kcl)
  162.         (when (eq (car decl-spec) 'ftype)
  163.           (dolist (name (cddr decl-spec))
  164.             (setf (get (declaimed-p-name name) 'ftype-declaimed-p) T)))
  165.         (push `(proclaim ',decl-spec) proclamations))
  166.       (if (cdr proclamations)
  167.           `(progn ,@proclamations)
  168.           (car proclamations)))))
  169.  
  170. #-(or cmu kcl)
  171. (defun function-ftype-declaimed-p (name)
  172.   "Returns whether the function given by name already has its ftype declaimed."
  173.   (get (declaimed-p-name name) 'ftype-declaimed-p))
  174.  
  175.  
  176. (deftype index () `(integer 0 ,most-positive-fixnum))
  177.  
  178. (defmacro pop-key-value (key
  179.                          settable-lambda-list
  180.                          &optional
  181.                          default-value)
  182.   ;;   If key is on the settable-lambda-list, then it and its value is
  183.   ;; destructively removed from the list, and its value is returned.
  184.   ;;   Else, default-value is returned and the settable-lambda-list
  185.   ;; stays the same.
  186.   (once-only (key)
  187.     `(let ((list-ptr ,settable-lambda-list))
  188.         (if (eq (car list-ptr) ,key)
  189.             (progn
  190.               (setf ,settable-lambda-list (cddr list-ptr))
  191.               (cadr list-ptr))
  192.           (progn
  193.             (setf list-ptr (cdr list-ptr))
  194.             (let ((next-cdr (cdr list-ptr)))
  195.               (loop (when (null next-cdr)
  196.                       (return ,default-value))
  197.                     (when (eq (car next-cdr) ,key)
  198.                       (setf (cdr list-ptr) (cddr next-cdr))
  199.                       (return (cadr next-cdr)))
  200.                     (setf next-cdr
  201.                           (cdr (setf list-ptr (cdr next-cdr)))))))))))
  202.  
  203. (defmacro copy-simple-vector (orig)
  204.   "Fast way to copy a simple-vector."
  205.   #-kcl
  206.   (once-only (orig)
  207.     `(let* ((i   0)
  208.             (n   (length (the simple-vector ,orig)))
  209.             (new (make-array n)))
  210.        (declare (type index i n) (type simple-vector new))
  211.        (tagbody
  212.          begin-loop
  213.            (if (>= i n) (go end-loop))
  214.            (setf (svref new i) (svref (the simple-vector ,orig) i))
  215.            (setf i (the index (1+ i)))
  216.            (go begin-loop)
  217.         end-loop)
  218.        new))
  219.   #+kcl
  220.   `(copy-seq (the simple-vector ,orig)))
  221.  
  222. (defun lambda-list-legal-p (lambda-list
  223.                             &optional
  224.                             (options-allowed-p T)
  225.                             (keywords-allowed lambda-list-keywords))
  226.   (when (listp lambda-list)
  227.     (dolist (element lambda-list T)
  228.       (unless (or (symbolp element)
  229.                   (memq element keywords-allowed)
  230.                   (and options-allowed-p (listp element)))
  231.         (return NIL)))))
  232.  
  233.  
  234. (defun lambda-list-required-args (lambda-list)
  235.   (let ((collection NIL))
  236.     (dolist (element lambda-list)
  237.       (if (memq element lambda-list-keywords)
  238.           (return)
  239.         (push element collection)))
  240.     (nreverse collection)))
  241.  
  242. (defun npermutation-p (list1 list2)
  243.   "Returns whether list1 is a permutation of list2"
  244.   (if (null list1)
  245.       (null list2)
  246.     (unless (null list2)
  247.       (when (memq (car list1) list2)
  248.          (npermutation-p (cdr list1)
  249.                          (delete (car list1) list2 :count 1))))))
  250.  
  251. (defun permutation-p (list1 list2)
  252.   "Returns whether list1 is a permutation of list2"
  253.   (npermutation-p list1 (copy-list list2)))
  254.  
  255. (defun count-non-nils (list)
  256.   "Returns the count of non nil elements in the list."
  257.   (if list
  258.       (let ((non-nil-count 0)
  259.             (list-ptr list))
  260.         (declare (type fixnum non-nil-count))
  261.         (loop (when (car list-ptr)
  262.                 (setf non-nil-count (the fixnum (1+ non-nil-count))))
  263.               (unless (setf list-ptr (cdr list-ptr))
  264.                 (return non-nil-count))))
  265.       0))
  266.  
  267. (eval-when (compile load eval)
  268. (proclaim '(ftype (function (T &optional T) (values T T T)) extract-declarations))
  269. (defun extract-declarations (body &optional environment)
  270.   (declare (values documentation declarations body))
  271.   (let (documentation declarations form)
  272.     (when (and (stringp (car body))
  273.            (cdr body))
  274.       (setq documentation (pop body)))
  275.     (block outer
  276.       (loop
  277.     (when (null body) (return-from outer nil))
  278.     (setq form (car body))
  279.     (when (block inner
  280.         (loop (cond ((not (listp form))
  281.                  (return-from outer nil))
  282.                 ((eq (car form) 'declare)
  283.                  (return-from inner 't))
  284.                 (t
  285.                  (multiple-value-bind (newform macrop)
  286.                   (macroexpand-1 form environment)
  287.                    (if (or (not (eq newform form)) macrop)
  288.                    (setq form newform)
  289.                  (return-from outer nil)))))))
  290.       (pop body)
  291.       (dolist (declaration (cdr form))
  292.         (push declaration declarations)))))
  293.     (values documentation
  294.         (and declarations `((declare ,.(nreverse declarations))))
  295.         body)))
  296. )
  297.  
  298. ;#+Lucid
  299. ;(eval-when (compile load eval)
  300. ;  (eval `(defstruct (,(intern "FASLESCAPE" (find-package 'lucid))))))
  301.  
  302. (defun make-keyword (symbol)
  303.   (intern (symbol-name symbol) *keyword-package*))
  304.  
  305. (eval-when (compile load eval)
  306.  
  307. (defun string-append (&rest strings)
  308.   (setq strings (copy-list strings))        ;The explorer can't even
  309.                         ;rplaca an &rest arg?
  310.   (do ((string-loc strings (cdr string-loc)))
  311.       ((null string-loc)
  312.        (apply #'concatenate 'string strings))
  313.     (rplaca string-loc (string (car string-loc)))))
  314. )
  315.  
  316. (defun symbol-append (sym1 sym2 &optional (package *package*))
  317.   (intern (string-append sym1 sym2) package))
  318.  
  319. (defmacro check-member (place list &key (test #'eql) (pretty-name place))
  320.   (once-only (place list)
  321.     `(or (member ,place ,list :test ,test)
  322.          (error "The value of ~A, ~S is not one of ~S."
  323.                 ',pretty-name ,place ,list))))
  324.  
  325. (defmacro alist-entry (alist key make-entry-fn)
  326.   (once-only (alist key)
  327.     `(or (assq ,key ,alist)
  328.      (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
  329.         (car ,alist)))))
  330.  
  331. ;;; A simple version of destructuring-bind.
  332.  
  333. ;;; This does no more error checking than CAR and CDR themselves do.  Some
  334. ;;; attempt is made to be smart about preserving intermediate values.  It
  335. ;;; could be better, although the only remaining case should be easy for
  336. ;;; the compiler to spot since it compiles to PUSH POP.
  337. ;;;
  338. ;;; Common Lisp BUG:
  339. ;;;    Common Lisp should have destructuring-bind.
  340. ;;;    
  341. (defmacro destructuring-bind (pattern form &body body)
  342.   (multiple-value-bind (ignore declares body)
  343.       (extract-declarations body)
  344.     (declare (ignore ignore))
  345.     (multiple-value-bind (setqs binds)
  346.     (destructure pattern form)
  347.       `(let ,binds
  348.      ,@declares
  349.      ,@setqs
  350.      (progn .destructure-form.)
  351.      . ,body))))
  352.  
  353. (eval-when (compile load eval)
  354. (defun destructure (pattern form)
  355.   (declare (values setqs binds))
  356.   (let ((*destructure-vars* ())
  357.     (setqs ()))
  358.     (declare (special *destructure-vars*))
  359.     (setq *destructure-vars* '(.destructure-form.)
  360.       setqs (list `(setq .destructure-form. ,form))
  361.       form '.destructure-form.)
  362.     (values (nconc setqs (nreverse (destructure-internal pattern form)))
  363.         (delete nil *destructure-vars*))))
  364.  
  365. (defun destructure-internal (pattern form)
  366.   ;; When we are called, pattern must be a list.  Form should be a symbol
  367.   ;; which we are free to setq containing the value to be destructured.
  368.   ;; Optimizations are performed for the last element of pattern cases.
  369.   ;; we assume that the compiler is smart about gensyms which are bound
  370.   ;; but only for a short period of time.
  371.   (declare (special *destructure-vars*))
  372.   (let ((gensym (gensym))
  373.     (pending-pops 0)
  374.     (var nil)
  375.     (setqs ()))
  376.     (declare (type fixnum pending-pops))
  377.     (labels
  378.         ((make-pop (var form pop-into)
  379.        (prog1 
  380.          (cond ((zerop pending-pops)
  381.             `(progn ,(and var `(setq ,var (car ,form)))
  382.                 ,(and pop-into `(setq ,pop-into (cdr ,form)))))
  383.            ((null pop-into)
  384.             (and var `(setq ,var ,(make-caxr pending-pops form))))
  385.            (t
  386.             `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
  387.                 ,(and var `(setq ,var (pop ,pop-into))))))
  388.          (setq pending-pops 0))))
  389.       (do ((pat pattern (cdr pat)))
  390.       ((null pat) ())
  391.     (if (symbolp (setq var (car pat)))
  392.         (progn
  393.           #-:coral (unless (memq var '(nil ignore))
  394.              (push var *destructure-vars*))
  395.           #+:coral (push var *destructure-vars*)          
  396.           (cond ((null (cdr pat))
  397.              (push (make-pop var form ()) setqs))
  398.             ((symbolp (cdr pat))
  399.              (push (make-pop var form (cdr pat)) setqs)
  400.              (push (cdr pat) *destructure-vars*)
  401.              (return ()))
  402.             #-:coral
  403.             ((memq var '(nil ignore)) (incf pending-pops))
  404.             #-:coral
  405.             ((memq (cadr pat) '(nil ignore))
  406.              (push (make-pop var form ()) setqs)
  407.              (incf pending-pops 1))
  408.             (t
  409.              (push (make-pop var form form) setqs))))
  410.         (progn
  411.           (push `(let ((,gensym ()))
  412.                ,(make-pop gensym
  413.                   form
  414.                   (if (symbolp (cdr pat)) (cdr pat) form))
  415.                ,@(nreverse
  416.                (destructure-internal
  417.                  (if (consp pat) (car pat) pat)
  418.                  gensym)))
  419.             setqs)
  420.           (when (symbolp (cdr pat))
  421.         (push (cdr pat) *destructure-vars*)
  422.         (return)))))
  423.       setqs)))
  424. )
  425.  
  426.  
  427. (defmacro collecting-once (&key initial-value)
  428.    `(let* ((head ,initial-value)
  429.            (tail ,(and initial-value `(last head))))
  430.           (values #'(lambda (value)
  431.                            (if (null head)
  432.                                (setq head (setq tail (list value)))
  433.                    (unless (memq value head)
  434.                  (setq tail
  435.                        (cdr (rplacd tail (list value)))))))
  436.           #'(lambda nil head))))
  437.  
  438. (defmacro doplist ((key val) plist &body body &environment env)
  439.   (multiple-value-bind (doc decls bod)
  440.       (extract-declarations body env)
  441.     (declare (ignore doc))
  442.     `(let ((.plist-tail. ,plist) ,key ,val)
  443.        ,@decls
  444.        (loop (when (null .plist-tail.) (return nil))
  445.          (setq ,key (pop .plist-tail.))
  446.          (when (null .plist-tail.)
  447.            (error "Malformed plist in doplist, odd number of elements."))
  448.          (setq ,val (pop .plist-tail.))
  449.          (progn ,@bod)))))
  450.  
  451. (defmacro if* (condition true &rest false)
  452.   `(if ,condition ,true (progn ,@false)))
  453.  
  454. (defmacro dolist-carefully ((var list improper-list-handler) &body body)
  455.   `(let ((,var nil)
  456.          (.dolist-carefully. ,list))
  457.      (loop (when (null .dolist-carefully.) (return nil))
  458.            (if (consp .dolist-carefully.)
  459.                (progn
  460.                  (setq ,var (pop .dolist-carefully.))
  461.                  ,@body)
  462.                (,improper-list-handler)))))
  463.  
  464.   ;;   
  465. ;;;;;; printing-random-thing
  466.   ;;
  467. ;;; Similar to printing-random-object in the lisp machine but much simpler
  468. ;;; and machine independent.
  469. (defmacro printing-random-thing ((thing stream) &body body)
  470.   (once-only (stream)
  471.   `(progn (format ,stream "#<")
  472.       ,@body
  473.       (format ,stream " ")
  474.       (printing-random-thing-internal ,thing ,stream)
  475.       (format ,stream ">"))))
  476.  
  477. (defun printing-random-thing-internal (thing stream)
  478.   (declare (ignore thing stream))
  479.   nil)
  480.  
  481.   ;;   
  482. ;;;;;; 
  483.   ;;
  484.  
  485. (defun capitalize-words (string &optional (dashes-p t))
  486.   (let ((string (copy-seq (string string))))
  487.     (declare (string string))
  488.     (do* ((flag t flag)
  489.       (length (length string) length)
  490.       (char nil char)
  491.       (i 0 (+ i 1)))
  492.      ((= i length) string)
  493.       (declare (type fixnum i length))
  494.       (setq char (elt string i))
  495.       (cond ((both-case-p char)
  496.          (if flag
  497.          (and (setq flag (lower-case-p char))
  498.               (setf (elt string i) (char-upcase char)))
  499.          (and (not flag) (setf (elt string i) (char-downcase char))))
  500.          (setq flag nil))
  501.         ((char-equal char #\-)
  502.          (setq flag t)
  503.          (unless dashes-p (setf (elt string i) #\space)))
  504.         (t (setq flag nil))))))
  505.  
  506. #-(or lucid kcl excl cmu cltl2 CLISP)
  507. (eval-when (compile)
  508. (warn "****** Things would go faster if you fix define-compiler-macro for
  509. your lisp")
  510. )
  511.  
  512. #+(or lucid kcl excl cmu cltl2)
  513. (defmacro define-compiler-macro (name arglist &body body)
  514.   `(#+lucid lcl:def-compiler-macro
  515.     #+kcl   si::define-compiler-macro
  516.     #+excl  excl::defcmacro
  517.     #+cmu   c:def-source-transform
  518.     #+cltl2 cl:define-compiler-macro
  519.         ,name ,arglist
  520.      ,@body))
  521.  
  522. #-(or lucid kcl excl cmu cltl2 CLISP)
  523. (defmacro define-compiler-macro (name arglist &body body)
  524.   (declare (ignore name arglist body))
  525.   NIL)
  526.  
  527. (defmacro safe-subtypep (type1 type2)
  528.   #+(or cmu kcl excl)
  529.   `(subtypep ,type1 ,type2)
  530.   #+lucid
  531.   (once-only (type1 type2)
  532.     `(if (and (lcl:type-specifier-p ,type1)
  533.               (lcl:type-specifier-p ,type2))
  534.          (subtypep ,type1 ,type2)
  535.          (values nil nil)))
  536.   #-(or cmu kcl excl lucid)
  537.   (declare (ignore type1 type2))
  538.   #-(or cmu kcl excl lucid)
  539.   `(values nil nil))
  540.  
  541. (defun make-constant-function (value)
  542.   #'(lambda (object)
  543.       (declare (ignore object))
  544.       value))
  545.  
  546. (defun function-returning-nil (x)
  547.   (declare (ignore x))
  548.   nil)
  549.  
  550. (defun documented-function-returning-nil (args next-methods)
  551.   (declare (ignore args next-methods))
  552.   nil)
  553.  
  554. (defun function-returning-t (x)
  555.   (declare (ignore x))
  556.   t)
  557.  
  558. (defun documented-function-returning-t (args next-methods)
  559.   (declare (ignore args next-methods))
  560.   t)
  561.  
  562.  
  563. #|| ; Anything that used this should use eval instead.
  564. (defun reduce-constant (old)
  565.   (let ((new (eval old)))
  566.     (if (eq new old)
  567.     new
  568.     (if (constantp new)
  569.         (reduce-constant new)
  570.         new))))
  571. ||#
  572.  
  573. (defmacro gathering1 (gatherer &body body)
  574.   `(gathering ((.gathering1. ,gatherer))
  575.      (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
  576.        ,@body)))
  577.  
  578. ;;;
  579. ;;; 
  580. ;;; 
  581. (defmacro vectorizing (&key (size 0))
  582.   `(let* ((limit ,size)
  583.       (result (make-array limit))
  584.       (index 0))
  585.      (declare (type fixnum index))
  586.      (values #'(lambda (value)
  587.          (if (= index limit)
  588.              (error "vectorizing more elements than promised.")
  589.              (progn
  590.                (setf (svref result index) value)
  591.                (setf index (the fixnum (1+ index)))
  592.                value)))
  593.          #'(lambda () result))))
  594.  
  595. ;;;
  596. ;;; These are augmented definitions of list-elements and list-tails from
  597. ;;; iterate.lisp.  These versions provide the extra :by keyword which can
  598. ;;; be used to specify the step function through the list.
  599. ;;;
  600. (defmacro *list-elements (list &key (by #'cdr))
  601.   `(let ((tail ,list))
  602.      #'(lambda (finish)
  603.      (if (endp tail)
  604.          (funcall finish)
  605.          (prog1 (car tail)
  606.                 (setq tail (funcall ,by tail)))))))
  607.  
  608. (defmacro *list-tails (list &key (by #'cdr))
  609.    `(let ((tail ,list))
  610.       #'(lambda (finish)
  611.           (prog1 (if (endp tail)
  612.              (funcall finish)
  613.              tail)
  614.              (setq tail (funcall ,by tail))))))
  615.  
  616.  
  617. ;;;
  618. ;;; Functions and types for dealing with functions.
  619. ;;;
  620.  
  621. (defun really-function-p (x)
  622.   "Returns whether  X is really a function (as per X3J13)"
  623.   #+cmu   (functionp x)
  624.   #+lucid (procedurep x)
  625.   #-(or cmu lucid)
  626.   (and (functionp x) (not (or (symbolp x) (consp x)))))
  627.  
  628. (defun really-compiled-function-p (function)
  629.   "Returns whether FUNCTION is really a compiled function and not an
  630.    interpreted function masquerading as a compiled function."
  631.   #-cmu
  632.   (compiled-function-p function)
  633.   #+cmu
  634.   (the boolean
  635.        (and (compiled-function-p function)
  636.             (not (eval:interpreted-function-p function)))))
  637.  
  638. (deftype real-function ()
  639.          #+cmu            'function
  640.          #+lucid          'system:procedure
  641.          #-(or cmu lucid) `(satisfies really-function-p))
  642.  
  643. (defmacro funcall-function (form &rest args)
  644.   #+cmu            `(funcall (the function ,form) ,@args)
  645.   #+lucid          `(funcall (the system:procedure ,form) ,@args)
  646.   #-(or cmu lucid) `(funcall ,form ,@args))
  647.  
  648. (defmacro apply-function (form &rest args)
  649.   #+cmu            `(apply (the function ,form) ,@args)
  650.   #+lucid          `(apply (the system:procedure ,form) ,@args)
  651.   #-(or cmu lucid) `(apply ,form ,@args))
  652.  
  653. (defmacro function-funcall (form &rest args)
  654.   `(funcall-function ,form ,@args))
  655.  
  656. (defmacro function-apply (form &rest args)
  657.   `(apply-function ,form ,@args))
  658.  
  659. (defmacro funcall-compiled (form &rest args)
  660.   `(funcall (the compiled-function ,form) ,@args))
  661.  
  662. (defmacro apply-compiled (form &rest args)
  663.   `(apply (the compiled-function ,form) ,@args))
  664.  
  665. (defmacro force-compile (fn-name)
  666.   "If the function named by FN-NAME isn't compiled, then compile it."
  667.   (once-only (fn-name)
  668.     `(unless (really-compiled-function-p (symbol-function ,fn-name))
  669.        (compile ,fn-name))))
  670.  
  671.  
  672.  
  673.  
  674. ;;;
  675. ;;; Convert a function name to its standard setf function name.  We have to
  676. ;;; do this hack because not all Common Lisps have yet converted to having
  677. ;;; setf function specs.
  678. ;;;
  679. ;;; In a port that does have setf function specs you can use those just by
  680. ;;; making the obvious simple changes to these functions.  The rest of PCL
  681. ;;; believes that there are function names like (SETF <foo>), this is the
  682. ;;; only place that knows about this hack.
  683. ;;;
  684. (eval-when (compile load eval)
  685. ; In 15e (and also 16c), using the built in setf mechanism costs 
  686. ; a hash table lookup every time a setf function is called.
  687. ; Uncomment the next line to use the built in setf mechanism.
  688. ;#+cmu (pushnew :setf *features*) 
  689. )
  690.  
  691. (eval-when (compile load eval)
  692.  
  693. (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
  694.  
  695. (defun make-setf-function-name (name)
  696.   (let ((pkg (symbol-package name)))
  697.     (if pkg
  698.     (intern (format nil "SETF ~A ~A"
  699.             (package-name pkg) (symbol-name name))
  700.           *the-pcl-package*)
  701.     (make-symbol (format nil "SETF ~A" (symbol-name name))))))
  702.  
  703. (defun get-internal-setf-function-name (name)
  704.   (or (gethash name *setf-function-names*)
  705.       (setf (gethash name *setf-function-names*)
  706.             (make-setf-function-name name))))
  707.  
  708. (defun get-setf-function-name (name)
  709.   #+setf `(setf ,name)
  710.   #-setf (get-internal-setf-function-name name))
  711.  
  712. ;;;
  713. ;;; Call this to define a setf macro for a function with the same behavior as
  714. ;;; specified by the SETF function cleanup proposal.  Specifically, this will
  715. ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
  716. ;;;
  717. ;;; do-standard-defsetf                  A macro interface for use at top level
  718. ;;;                                      in files.  Unfortunately, users may
  719. ;;;                                      have to use this for a while.
  720. ;;;                                      
  721. ;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
  722. ;;; 
  723. ;;; do-standard-defsetf-1                A functional interface called by the
  724. ;;;                                      above, defmethod and defgeneric.
  725. ;;;                                      Since this is all a crock anyways,
  726. ;;;                                      users are free to call this as well.
  727. ;;;
  728. (defmacro do-standard-defsetf (&rest function-names)
  729.   `(eval-when (compile load eval)
  730.      (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
  731.  
  732. (defun do-standard-defsetfs-for-defclass (accessors)
  733.   (dolist (name accessors) (do-standard-defsetf-1 name)))
  734.  
  735. (defun do-standard-defsetf-1 (function-name)
  736.   #+setf
  737.   (declare (ignore function-name))
  738.   #+setf nil
  739.   #-setf
  740.   (unless (and (setfboundp function-name)
  741.            (get function-name 'standard-setf))
  742.     (setf (get function-name 'standard-setf) t)
  743.     (let* ((setf-function-name (get-setf-function-name function-name)))
  744.     
  745.       #+Genera
  746.       (let ((fn #'(lambda (form)
  747.             (lt::help-defsetf
  748.               '(&rest accessor-args) '(new-value) function-name 'nil
  749.               `(`(,',setf-function-name ,new-value .,accessor-args))
  750.               form))))
  751.     (setf (get function-name 'lt::setf-method) fn
  752.           (get function-name 'lt::setf-method-internal) fn))
  753.  
  754.       #+Lucid
  755.       (lucid::set-simple-setf-method 
  756.     function-name
  757.     #'(lambda (form new-value)
  758.         (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
  759.                      (cdr form)))
  760.            (vars (mapcar #'car bindings)))
  761.           ;; This may wrap spurious LET bindings around some form,
  762.           ;;   but the PQC compiler will unwrap then.
  763.           `(LET (,.bindings)
  764.          (,setf-function-name ,new-value . ,vars)))))
  765.       
  766.       #+kcl
  767.       (let ((helper (gensym)))
  768.     (setf (macro-function helper)
  769.           #'(lambda (form env)
  770.           (declare (ignore env))
  771.           (let* ((loc-args (butlast (cdr form)))
  772.              (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
  773.              (vars (mapcar #'car bindings)))
  774.             `(let ,bindings
  775.                (,setf-function-name ,(car (last form)) ,@vars)))))
  776.     (eval `(defsetf ,function-name ,helper)))
  777.       #+Xerox
  778.       (flet ((setf-expander (body env)
  779.            (declare (ignore env))
  780.            (let ((temps
  781.                (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
  782.                    (cdr body)))
  783.              (forms (cdr body))
  784.              (vars (list (gensym))))
  785.          (values temps
  786.              forms
  787.              vars
  788.              `(,setf-function-name ,@vars ,@temps)
  789.              `(,function-name ,@temps)))))
  790.     (let ((setf-method-expander (intern (concatenate 'string
  791.                                  (symbol-name function-name)
  792.                                  "-setf-expander")
  793.                      (symbol-package function-name))))
  794.       (setf (get function-name :setf-method-expander) setf-method-expander
  795.         (symbol-function setf-method-expander) #'setf-expander)))
  796.       
  797.       #-(or Genera Lucid kcl Xerox)
  798.       (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
  799.            (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
  800.               (vars (mapcar #'car bindings)))
  801.           `(let ,bindings
  802.               (,',setf-function-name ,new-value ,@vars)))))
  803.       
  804.       )))
  805.  
  806. (defun setfboundp (symbol)
  807.   #-(or Genera Lucid KCL Xerox :coral cmu CLISP)
  808.   (declare (ignore symbol))
  809.   #+Genera (not (null (get-properties (symbol-plist symbol)
  810.                       'lt::(derived-setf-function trivial-setf-method
  811.                         setf-equivalence setf-method))))
  812.   #+Lucid  (locally
  813.          (declare (special lucid::*setf-inverse-table*
  814.                    lucid::*simple-setf-method-table*
  815.                    lucid::*setf-method-expander-table*))
  816.          (or (gethash symbol lucid::*setf-inverse-table*)
  817.          (gethash symbol lucid::*simple-setf-method-table*)
  818.          (gethash symbol lucid::*setf-method-expander-table*)))
  819.   #+kcl    (or (get symbol 'si::setf-method)
  820.            (get symbol 'si::setf-update-fn)
  821.            (get symbol 'si::setf-lambda))
  822.   #+Xerox  (or (get symbol :setf-inverse)
  823.            (get symbol 'il:setf-inverse)
  824.            (get symbol 'il:setfn)
  825.            (get symbol :shared-setf-inverse)
  826.            (get symbol :setf-method-expander)
  827.            (get symbol 'il:setf-method-expander))
  828.   #+:coral (or (get symbol 'ccl::setf-inverse)
  829.            (get symbol 'ccl::setf-method-expander))
  830.   #+cmu (fboundp `(setf ,symbol))
  831.   #+CLISP (get symbol 'sys::setf-expander)
  832.   #-(or Genera Lucid KCL Xerox :coral cmu CLISP) nil)
  833.  
  834. );eval-when
  835.  
  836.  
  837. ;;;
  838. ;;; PCL, like user code, must endure the fact that we don't have a properly
  839. ;;; working setf.  Many things work because they get mentioned by a defclass
  840. ;;; or defmethod before they are used, but others have to be done by hand.
  841. ;;; 
  842. (do-standard-defsetf
  843.   class-wrapper                                 ;***
  844.   generic-function-name
  845.   method-function-plist
  846.   method-function-get
  847.   plist-value
  848.   object-plist
  849.   gdefinition
  850.   slot-value-using-class
  851.   )
  852.  
  853. (defsetf slot-value set-slot-value)
  854.  
  855. (defvar *redefined-functions* nil)
  856. (defvar *redefined-macros* nil)
  857.  
  858. (defmacro original-definition (name)
  859.   `(get ,name ':definition-before-pcl))
  860.  
  861. (defun redefine-function (name new)
  862.   (pushnew name *redefined-functions*)
  863.   (unless (original-definition name)
  864.     (setf (original-definition name)
  865.       (symbol-function name)))
  866.   (setf (symbol-function name)
  867.     (symbol-function new)))
  868.  
  869. (defun redefine-macro (name new)
  870.   (pushnew name *redefined-macros*)
  871.   (unless (original-definition name)
  872.     (setf (original-definition name)
  873.       (macro-function name)))
  874.   (setf (macro-function name)
  875.     (macro-function new)))
  876.  
  877. (defun pcl::reset-pcl-package ()        ; Try to do this safely
  878.   (let* ((vars '(pcl::*pcl-directory* 
  879.          pcl::*default-pathname-extensions* 
  880.          pcl::*pathname-extensions*
  881.          pcl::*redefined-functions*))
  882.      (names (mapcar #'symbol-name vars))
  883.      (values (mapcar #'symbol-value vars)))
  884.     (let ((pkg (find-package "PCL")))
  885.       (do-symbols (sym pkg)
  886.     (when (eq pkg (symbol-package sym))
  887.       (if (constantp sym)
  888.           (unintern sym pkg)
  889.           (progn
  890.         (makunbound sym)
  891.         (unless (eq sym 'pcl::reset-pcl-package)
  892.           (fmakunbound sym))
  893.         #+cmu (fmakunbound `(setf ,sym))
  894.         (setf (symbol-plist sym) nil))))))
  895.     (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
  896.       (when pkg
  897.     (do-symbols (sym pkg)
  898.       (makunbound sym)
  899.       (fmakunbound sym)
  900.       (setf (symbol-plist sym) nil))))
  901.     (let ((pcl (find-package "PCL")))
  902.       (mapcar #'(lambda (name value)
  903.           (let ((var (intern name pcl)))
  904.             (proclaim `(special ,var))
  905.             (set var value)))
  906.           names values))      
  907.     (dolist (sym pcl::*redefined-functions*)
  908.       (setf (symbol-function sym) (get sym ':definition-before-pcl)))
  909.     nil))
  910.  
  911.